home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / glass / glass.lha / GLASS / tmc / calu.ct < prev    next >
Text File  |  1990-11-06  |  38KB  |  1,888 lines
  1. /* 
  2.    Copyright (C) 1990 C van Reewijk, email: dutentb.uucp!reeuwijk
  3.  
  4. This file is part of GLASS.
  5.  
  6. GLASS is free software; you can redistribute it and/or modify
  7. it under the terms of the GNU General Public License as published by
  8. the Free Software Foundation; either version 1, or (at your option)
  9. any later version.
  10.  
  11. GLASS is distributed in the hope that it will be useful,
  12. but WITHOUT ANY WARRANTY; without even the implied warranty of
  13. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. GNU General Public License for more details.
  15.  
  16. You should have received a copy of the GNU General Public License
  17. along with GLASS; see the file COPYING.  If not, write to
  18. the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */
  19.  
  20. .. file: calu.ct
  21. .. tm C support. Variant: array lists, union constructors.
  22. ..
  23. .. The following variables must be set in tm:
  24. .. basename:     the name of the module. used to generate init_.. and stat_..
  25. .. wantdefs:     the names of the wanted definitions.
  26. ..  OR
  27. .. alldefs:      All code.
  28. ..
  29. .. The following C pre-processor variables may be defined:
  30. .. STAT          If you want code for statistics.
  31. ..               Statistics are written to 'FILE *statstream'.
  32. .. FATAL(msg)    If you want to supply a fatal error handler to print 'msg'.
  33. ..               A default is provided.
  34. .. FIRSTROOM     Initial room in lists. A default is provided.
  35. .. DUMMYCODE     If not defined to 0, dummy code is generated that gives
  36. ..               the same impression as the real code to lint, but is much
  37. ..               smaller. If not defined, it is defined locally to be 1
  38. ..               if 'lint' is defined, else it is defined to be 0.
  39. ..
  40. .. Possible declaration or #define'ing of statstream must be done
  41. .. outside this module.
  42. .set teststdc "#if defined( __STDC__ ) && __STDC__>0"
  43. .if ${index stat_$(basename) $(need_misc)}
  44. .set statcode 1
  45. .else
  46. .set statcode 0
  47. .endif
  48. /* ---- start of ${tplfilename} ---- */
  49.  
  50. /* Routines for '$(basename)'.
  51.  
  52.    template file:      ${tplfilename}
  53.    datastructure file: ${dsfilename}
  54.    tm version:         $(tmvers) ($(tmdate))
  55.  */
  56.  
  57. $(teststdc)
  58. #else
  59. #define const
  60. #endif
  61.  
  62. /* The defines below are necessary to stop complaints on various machines
  63.  * about incompatible types to realloc() and free(). On hpux v7.0 a void *
  64.  * are used, but not interpreted as a neutral pointer type. AAAARGGHHH.
  65.  */
  66. $(teststdc)
  67. #define TMREALLOC realloc
  68. #define TMFREE free
  69. #else
  70. #ifdef hp9000s300
  71. /* Actually, this is not accurate enough, but I don't know how to
  72.  * solve this.
  73.  */
  74. #define TMREALLOC(p,n) realloc((void *)(p),n)
  75. #define TMFREE(p) free((void *)(p))
  76. #else
  77. #define TMREALLOC(p,n) realloc((char *)(p),n)
  78. #define TMFREE(p) free((char *)(p))
  79. #endif
  80. #endif
  81.  
  82. /* If DUMMYCODE is 1, fake code is generated to give lint the right
  83.  * impression of the real code and not choke it with
  84.  * that real code.
  85.  */
  86. #ifndef DUMMYCODE
  87. #define DUMMYCODE 0
  88. #endif
  89.  
  90. #if DUMMYCODE==0
  91. .if $(statcode)
  92. #ifdef STAT
  93. .foreach t $(need_stat_list)
  94. static long newcnt_$t_list = 0;
  95. static long frecnt_$t_list = 0;
  96. static long hitcnt_$t_list = 0;
  97. .endforeach
  98.  
  99. .foreach t $(need_stat)
  100. .if ${strlen ${telmlist $t}}
  101. static long newcnt_$t = 0;
  102. static long frecnt_$t = 0;
  103. static long hitcnt_$t = 0;
  104. .else
  105. .foreach c ${conslist $t}
  106. static long newcnt_$c = 0;
  107. static long frecnt_$c = 0;
  108. static long hitcnt_$c = 0;
  109. .endforeach
  110. .endif
  111. .endforeach
  112. #endif
  113.  
  114. .endif
  115.  
  116. /* Caching variables.
  117.  *
  118.  * For each type or type list array of CACHESZ elements is maintained that
  119.  * is filled by the fre_<type>() routines. If possible new_<type>() or
  120.  * new_<cons> uses these elements.
  121.  *
  122.  * Although type elements can be shared by all constructors of a type, the
  123.  * cache hit counts are maintained separately.
  124.  *
  125.  * All cacheix_<type> variables maintain the index of the first
  126.  * free element in the array.
  127.  */
  128. #ifndef CACHESZ
  129. #define CACHESZ 5
  130. #endif
  131.  
  132. #ifdef USECACHE
  133. #undef USECACHE
  134. #endif
  135.  
  136. #if CACHESZ==0
  137. #else
  138. #define USECACHE
  139. #endif
  140.  
  141. #ifdef USECACHE
  142. .foreach t ${uniq $(need_new_list) $(need_fre_list)}
  143. static short int cacheix_$t_list = 0;
  144. static $t_list cache_$t_list[CACHESZ]; 
  145. .endforeach
  146. .foreach t ${uniq $(need_new) $(need_fre)}
  147. static short int cacheix_$t = 0;
  148. static $t cache_$t[CACHESZ];
  149. .endforeach
  150. #endif
  151.  
  152. static const char tm_srcfile[] = __FILE__;
  153.  
  154. .if $(statcode)
  155. #ifdef STAT
  156. static const char tm_allocfreed[] = "%-15s: %6ld allocated, %6ld freed, %6ld cache hits.%s\n";
  157. #endif
  158. .endif
  159.  
  160. #ifndef FIRSTROOM
  161. /* Default initial room in arrays. (uneducated guess). */
  162. #define FIRSTROOM 2
  163. #endif
  164.  
  165. #ifndef FATAL
  166. #define FATAL(msg) tmfatal(tm_srcfile,__LINE__,msg)
  167. #endif
  168.  
  169. #ifndef WORDBUFSIZE
  170. #define WORDBUFSIZE 100
  171. #endif
  172.  
  173. /* Possible error strings. */
  174. static const char tm_outofmemory[] = "out of memory";
  175. .if ${strlen $(need_del_list) $(need_ins_list)}
  176. static const char tm_nilptr[] = "NIL pointer";
  177. .endif
  178. .if ${strlen $(need_fscan)}
  179. static const char tm_badcons[] = "bad constructor for %s: '%s'";
  180. .endif
  181. .if ${strlen $(need_fscan_list)}
  182. static const char tm_badeof[] = "unexpected end of file";
  183. .endif
  184.  
  185. #ifndef FATALTAG
  186. #define FATALTAG(tag) tmbadtag(tm_srcfile,__LINE__,tag)
  187. #endif
  188.  
  189. /**************************************************
  190.  *    array room routines                         *
  191.  **************************************************/
  192. $(teststdc)
  193. .foreach t $(need_room_list)
  194. .if ${index $t $(want_room_list)}
  195. .else
  196. static void room_$t_list( $t_list, unsigned int );
  197. .endif
  198. .endforeach
  199. #endif
  200.  
  201. .foreach t $(need_room_list)
  202. .set stic_$t "static "
  203. .endforeach
  204. .foreach t $(want_room_list)
  205. .set stic_$t
  206. .endforeach
  207. .foreach t $(need_room_list)
  208. /* Announce that you will need room for 'rm' elements in
  209.     $t_list 'l'.
  210.  */
  211. $(stic_$t)void room_$t_list( l, rm )
  212.  register $t_list l;
  213.  register unsigned int rm;
  214. {
  215.     if( l->room>rm ){
  216.     return;
  217.     }
  218.     l->arr = ($t *) TMREALLOC( l->arr, rm * sizeof(*(l->arr)) );
  219.     if( l->arr == ($t *)0 ){
  220.     FATAL( tm_outofmemory );
  221.     }
  222.     l->room = rm;
  223. }
  224.  
  225. .endforeach
  226. /**************************************************
  227.  *    Allocation routines                         *
  228.  **************************************************/
  229.  
  230. $(teststdc)
  231. .foreach t $(need_new_list)
  232. .if ${index $t $(want_new_list)}
  233. .else
  234. static $t_list new_$t_list( void );
  235. .endif
  236. .endforeach
  237. .foreach t $(need_new)
  238. .if ${index $t $(want_new)}
  239. .else
  240. .if ${len ${telmlist $t}}
  241. .set tl
  242. .foreach e ${telmlist $t}
  243. .if ${eq single ${ttypeclass $t $e}}
  244. .append tl ${ttypename $t $e}
  245. .else
  246. .append tl ${ttypename $t $e}_list
  247. .endif
  248. .endforeach
  249. .if ${== ${len $(tl)} 0}
  250. static $t new_$t( void );
  251. .else
  252. static $t new_$t( ${seplist ", " $(tl)} );
  253. .endif
  254. .else
  255. .foreach c ${conslist $t}
  256. .set tl
  257. .foreach e ${celmlist $t $c}
  258. .if ${eq single ${ctypeclass $t $c $e}}
  259. .append tl ${ctypename $t $c $e}
  260. .else
  261. .append tl ${ctypename $t $c $e}_list
  262. .endif
  263. .endforeach
  264. .if ${== ${len $(tl)} 0}
  265. static $t new_$c( void );
  266. .else
  267. static $t new_$c( ${seplist ", " $(tl)} );
  268. .endif
  269. .endforeach
  270. .endif
  271. .endif
  272. .endforeach
  273. #endif
  274.  
  275. .foreach t $(need_new_list)
  276. .set stic_$t "static "
  277. .endforeach
  278. .foreach t $(want_new_list)
  279. .set stic_$t
  280. .endforeach
  281. .foreach t $(need_new_list)
  282. $(stic_$t)$t_list new_$t_list()
  283. {
  284.     $t_list new;
  285.  
  286. #ifdef USECACHE
  287.     if( cacheix_$t_list > 0 ){
  288.     new = cache_$t_list[--cacheix_$t_list];
  289. .if $(statcode)
  290. #ifdef STAT
  291.     hitcnt_$t_list++;
  292. #endif
  293. .endif
  294.     }
  295.     else {
  296. #endif
  297.     new = ($t_list) malloc( sizeof(*new) );
  298.     if( (char *)new == (char *)0 ){
  299.         FATAL( tm_outofmemory );
  300.     }
  301. #ifdef USECACHE
  302.     }
  303. #endif
  304.     new->sz = 0;
  305.     new->arr = ($t *) malloc( FIRSTROOM*sizeof( *(new->arr) ) );
  306.     new->room = FIRSTROOM;
  307.     if( (char *)new->arr == (char *)0 ){
  308.     FATAL( tm_outofmemory );
  309.     }
  310. .if $(statcode)
  311. #ifdef STAT
  312.     newcnt_$t_list++;
  313. #endif
  314. .endif
  315.     return new;
  316. }
  317.  
  318. .endforeach
  319. .foreach t $(need_new)
  320. .set stic_$t "static "
  321. .endforeach
  322. .foreach t $(want_new)
  323. .set stic_$t
  324. .endforeach
  325. .foreach t $(need_new)
  326. .if ${strlen ${telmlist $t}}
  327. .. new_<tuple>
  328. $(stic_$t)$t new_$t( ${seplist ", " ${prefix "p_" ${telmlist $t}}} )
  329. .foreach sname ${telmlist $t}
  330. .if ${eq list ${ttypeclass $t $(sname)}}
  331.  ${ttypename $t $(sname)}_list p_$(sname);
  332. .else
  333.  ${ttypename $t $(sname)} p_$(sname);
  334. .endif
  335. .endforeach
  336. {
  337.     register $t new;
  338.  
  339. #ifdef USECACHE
  340.     if( cacheix_$t > 0 ){
  341.     new = cache_$t[--cacheix_$t];
  342. .if $(statcode)
  343. #ifdef STAT
  344.     hitcnt_$t++;
  345. #endif
  346. .endif
  347.     }
  348.     else {
  349. #endif
  350.     new = ($t) malloc( sizeof(*new));
  351.     if( (char *)new == (char *)0 ){
  352.         FATAL( tm_outofmemory );
  353.     }
  354. #ifdef USECACHE
  355.     }
  356. #endif
  357. .foreach sname ${telmlist $t}
  358.     new->$(sname) = p_$(sname);
  359. .endforeach
  360. .if $(statcode)
  361. #ifdef STAT
  362.     newcnt_$t++;
  363. #endif
  364. .endif
  365.     return new;
  366. }
  367.  
  368. .else
  369. .. new_<cons>
  370. .foreach c ${conslist $t}
  371. $(stic_$t)$t new_$c( ${seplist ", " ${prefix "p_" ${celmlist $t $c}}} )
  372. .foreach sname ${celmlist $t $c}
  373. .if ${eq list ${ctypeclass $t $c $(sname)}}
  374.  ${ctypename $t $c $(sname)}_list p_$(sname);
  375. .else
  376.  ${ctypename $t $c $(sname)} p_$(sname);
  377. .endif
  378. .endforeach
  379. {
  380.     register $t new;
  381.  
  382. #ifdef USECACHE
  383.     if( cacheix_$t > 0 ){
  384.     new = cache_$t[--cacheix_$t];
  385. .if $(statcode)
  386. #ifdef STAT
  387.     hitcnt_$c++;
  388. #endif
  389. .endif
  390.     }
  391.     else {
  392. #endif
  393.     new = ($t) malloc( sizeof(*new));
  394.     if( (char *)new == (char *)0 ){
  395.         FATAL( tm_outofmemory );
  396.     }
  397. #ifdef USECACHE
  398.     }
  399. #endif
  400.     new->tag = TAG$c;
  401. .foreach sname ${celmlist $t $c}
  402.     new->$c.$(sname) = p_$(sname);
  403. .endforeach
  404. .if $(statcode)
  405. #ifdef STAT
  406.     newcnt_$c++;
  407. #endif
  408. .endif
  409.     return new;
  410. }
  411.  
  412. .endforeach
  413. .endif
  414. .endforeach
  415. /**************************************************
  416.  *    Freeing routines                            *
  417.  **************************************************/
  418.  
  419. $(teststdc)
  420. .foreach t $(need_fre_list)
  421. .if ${index $t $(want_fre_list)}
  422. .else
  423. static void fre_$t_list( $t_list );
  424. .endif
  425. .endforeach
  426. .foreach t $(need_fre)
  427. .if ${index $t $(want_fre)}
  428. .else
  429. static void fre_$t( $t );
  430. .endif
  431. .endforeach
  432. #endif
  433.  
  434. .foreach t $(need_fre)
  435. .set stic_$t "static "
  436. .endforeach
  437. .foreach t $(want_fre)
  438. .set stic_$t
  439. .endforeach
  440. .foreach t $(need_fre)
  441. .if ${strlen ${telmlist $t}}
  442. .. fre_<tuple>
  443. /* Free an element 'e' of type '$t'. */
  444. $(stic_$t)void fre_$t( e )
  445.  $t e;
  446. {
  447.     if( e == $tNIL ){
  448.     return;
  449.     }
  450. .if $(statcode)
  451. #ifdef STAT
  452.     frecnt_$t++;
  453. #endif
  454. .endif
  455. #ifdef USECACHE
  456.     if( cacheix_$t<CACHESZ ){
  457.     cache_$t[cacheix_$t++] = e;
  458.     return;
  459.     }
  460. #endif
  461.     TMFREE( e );
  462. }
  463.  
  464. .else
  465. .. fre_<cons>
  466. /* Free an element 'e' of type '$t'. */
  467. $(stic_$t)void fre_$t( e )
  468.  $t e;
  469. {
  470.     if( e == $tNIL ){
  471.     return;
  472.     }
  473. .if $(statcode)
  474. #ifdef STAT
  475.     switch( e->tag ){
  476. .foreach c ${conslist $t}
  477.     case TAG$c:
  478.         frecnt_$c++;
  479.         break;
  480.  
  481. .endforeach
  482.     default:
  483.         FATALTAG( (int) e->tag );
  484.     }
  485. #endif
  486. .endif
  487. #ifdef USECACHE
  488.     if( cacheix_$t<CACHESZ ){
  489.     cache_$t[cacheix_$t++] = e;
  490.     return;
  491.     }
  492. #endif
  493.     TMFREE( e );
  494. }
  495.  
  496. .endif
  497. .endforeach
  498. .foreach t $(need_fre_list)
  499. .set stic_$t "static "
  500. .endforeach
  501. .foreach t $(want_fre_list)
  502. .set stic_$t
  503. .endforeach
  504. .foreach t $(need_fre_list)
  505. /* Free a list of $t elements 'l'. */
  506. $(stic_$t)void fre_$t_list( l )
  507.  $t_list l;
  508. {
  509.     if( l == $t_listNIL ){
  510.     return;
  511.     }
  512. .if $(statcode)
  513. #ifdef STAT
  514.     frecnt_$t_list++;
  515. #endif
  516. .endif
  517.     TMFREE( l->arr );
  518. #ifdef USECACHE
  519.     if( cacheix_$t_list<CACHESZ ){
  520.     cache_$t_list[cacheix_$t_list++] = l;
  521.     return;
  522.     }
  523. #endif
  524.     TMFREE( l );
  525. }
  526.  
  527. .endforeach
  528. /**************************************************
  529.  *    Append routines                             *
  530.  **************************************************/
  531.  
  532. $(teststdc)
  533. .foreach t $(need_app_list)
  534. .if ${index $t $(want_app_list)}
  535. .else
  536. static void app_$t_list( $t_list, $t );
  537. .endif
  538. .endforeach
  539. #endif
  540.  
  541. .foreach t $(need_app_list)
  542. .set stic_$t "static "
  543. .endforeach
  544. .foreach t $(want_app_list)
  545. .set stic_$t
  546. .endforeach
  547. .foreach t $(need_app_list)
  548. /* Append a $t element 'e' to list 'l'. */
  549. $(stic_$t)void app_$t_list( l, e )
  550.  $t_list l;
  551.  $t e;
  552. {
  553.     if( l->sz >= l->room ){
  554.     room_$t_list( l, (l->sz)+(l->sz) );
  555.     }
  556.     l->arr[l->sz] = e;
  557.     l->sz++;
  558. }
  559.  
  560. .endforeach
  561. /**************************************************
  562.  *    Real append routines                        *
  563.  **************************************************/
  564.  
  565. $(teststdc)
  566. .foreach t $(need_append_list)
  567. .if ${index $t $(want_append_list)}
  568. .else
  569. static $t_list append_$t_list( $t_list, $t );
  570. .endif
  571. .endforeach
  572. #endif
  573.  
  574. .foreach t $(need_append_list)
  575. .set stic_$t "static "
  576. .endforeach
  577. .foreach t $(want_append_list)
  578. .set stic_$t
  579. .endforeach
  580. .foreach t $(need_append_list)
  581. /* Append a $t element 'e' to list 'l', and return the new list. */
  582. $(stic_$t)$t_list append_$t_list( l, e )
  583.  $t_list l;
  584.  $t e;
  585. {
  586.     if( l->sz >= l->room ){
  587.     room_$t_list( l, (l->sz)+(l->sz) );
  588.     }
  589.     l->arr[l->sz] = e;
  590.     l->sz++;
  591.     return l;
  592. }
  593.  
  594. .endforeach
  595. /**************************************************
  596.  *    ins_<type>_list routines                    *
  597.  **************************************************/
  598.  
  599. $(teststdc)
  600. .foreach t $(need_ins_list)
  601. .if ${index $t $(want_ins_list)}
  602. .else
  603. static void ins_$t_list( $t_list, unsigned int, $t );
  604. .endif
  605. .endforeach
  606. #endif
  607.  
  608. .foreach t $(need_ins_list)
  609. .set stic_$t "static "
  610. .endforeach
  611. .foreach t $(want_ins_list)
  612. .set stic_$t
  613. .endforeach
  614. .foreach t $(need_ins_list)
  615. /* Insert a $t element 'e' to into list 'l' at position 'pos'. */
  616. $(stic_$t)void ins_$t_list( l, pos, e )
  617.  register $t_list l;
  618.  unsigned int pos;
  619.  $t e;
  620. {
  621.     register unsigned int ix;
  622.  
  623.     if( l == $t_listNIL ){
  624.     FATAL( tm_nilptr );
  625.     }
  626.     if( l->sz >= l->room ){
  627.     room_$t_list( l, (l->sz)+(l->sz) );
  628.     }
  629.     if( pos>l->sz ) pos = l->sz;
  630.     for( ix=l->sz; ix>pos; ix-- ){
  631.     l->arr[ix] = l->arr[ix-1];
  632.     }
  633.     l->sz++;
  634.     l->arr[pos] = e;
  635. }
  636.  
  637. .endforeach
  638. /**************************************************
  639.  *    Concatenate routines                        *
  640.  **************************************************/
  641.  
  642. $(teststdc)
  643. .foreach t $(need_conc_list)
  644. .if ${index $t $(want_conc_list)}
  645. .else
  646. static void conc_$t_list( $t_list, $t_list );
  647. .endif
  648. .endforeach
  649. #endif
  650.  
  651. .foreach t $(need_conc_list)
  652. .set stic_$t "static "
  653. .endforeach
  654. .foreach t $(want_conc_list)
  655. .set stic_$t
  656. .endforeach
  657. .foreach t $(need_conc_list)
  658. /* Concatenate $t list 'lb' after $t list 'la'.
  659.    The list descriptor of list 'lb' is freed,
  660.    since its contents has been moved to 'la'.
  661.  */
  662. $(stic_$t)void conc_$t_list( la, lb )
  663.  $t_list la;
  664.  $t_list lb;
  665. {
  666.     register unsigned int cnt;
  667.     register $t *sp;
  668.     register $t *dp;
  669.  
  670.     room_$t_list( la, la->sz+lb->sz );
  671.     cnt = lb->sz;
  672.     sp = lb->arr;
  673.     dp = &la->arr[la->sz];
  674.     while( cnt!=0 ){
  675.     *dp++ = *sp++;
  676.     cnt--;
  677.     }
  678.     la->sz += lb->sz;
  679.     fre_$t_list( lb );
  680. }
  681.  
  682. .endforeach
  683. /**********************************************
  684.  *    Real concatenate routines               *
  685.  **********************************************/
  686.  
  687. $(teststdc)
  688. .foreach t $(need_concat_list)
  689. .if ${index $t $(want_concat_list)}
  690. .else
  691. static $t_list concat_$t_list( $t_list, $t_list );
  692. .endif
  693. .endforeach
  694. #endif
  695.  
  696. .foreach t $(need_concat_list)
  697. .set stic_$t "static "
  698. .endforeach
  699. .foreach t $(want_concat_list)
  700. .set stic_$t
  701. .endforeach
  702. .foreach t $(need_concat_list)
  703. /* Concatenate $t list 'lb' after $t list 'la'.
  704.    The list descriptor of list 'lb' is freed,
  705.    since its contents has been moved to 'la'.
  706.  */
  707. $(stic_$t)$t_list concat_$t_list( la, lb )
  708.  $t_list la;
  709.  $t_list lb;
  710. {
  711.     register unsigned int cnt;
  712.     register $t *sp;
  713.     register $t *dp;
  714.  
  715.     room_$t_list( la, la->sz+lb->sz );
  716.     cnt = lb->sz;
  717.     sp = lb->arr;
  718.     dp = &la->arr[la->sz];
  719.     while( cnt!=0 ){
  720.     *dp++ = *sp++;
  721.     cnt--;
  722.     }
  723.     la->sz += lb->sz;
  724.     fre_$t_list( lb );
  725.     return la;
  726. }
  727.  
  728. .endforeach
  729. /**************************************************
  730.  *    Recursive freeing routines                  *
  731.  **************************************************/
  732.  
  733. $(teststdc)
  734. .foreach t $(need_rfre)
  735. .if ${index $t $(want_rfre)}
  736. .else
  737. static void rfre_$t( $t );
  738. .endif
  739. .endforeach
  740. .foreach t $(need_rfre_list)
  741. .if ${index $t $(want_rfre_list)}
  742. .else
  743. static void rfre_$t_list( $t_list );
  744. .endif
  745. .endforeach
  746. #endif
  747.  
  748. .. Forward declarations
  749. .foreach t $(need_rfre)
  750. .if ${index $t $(want_rfre)}
  751. .else
  752. static void rfre_$t();
  753. .endif
  754. .endforeach
  755. .foreach t $(need_rfre_list)
  756. .if ${index $t $(want_rfre_list)}
  757. .else
  758. static void rfre_$t_list();
  759. .endif
  760. .endforeach
  761.  
  762. .foreach t $(need_rfre)
  763. .set stic_$t "static "
  764. .endforeach
  765. .foreach t $(want_rfre)
  766. .set stic_$t
  767. .endforeach
  768. .foreach t $(need_rfre)
  769. /* Recursively free an element 'e' of type '$t'
  770.    and all elements in it.
  771.  */
  772. .if ${strlen ${telmlist $t}}
  773. $(stic_$t)void rfre_$t( e )
  774.  $t e;
  775. {
  776.     if( e == $tNIL ){
  777.     return;
  778.     }
  779. .foreach sname ${telmlist $t}
  780. .if ${eq list ${ttypeclass $t $(sname)}}
  781.     rfre_${ttypename $t $(sname)}_list( e->$(sname) );
  782. .else
  783.     rfre_${ttypename $t $(sname)}( e->$(sname) );
  784. .endif
  785. .endforeach
  786.     fre_$t( e );
  787. }
  788.  
  789. .else
  790. $(stic_$t)void rfre_$t( e )
  791.  $t e;
  792. {
  793.     if( e == $tNIL ){
  794.     return;
  795.     }
  796.     switch( e->tag ){
  797. .foreach c ${conslist $t}
  798.     case TAG$c:
  799. .foreach sname ${celmlist $t $c}
  800. .if ${eq list ${ctypeclass $t $c $(sname)}}
  801.         rfre_${ctypename $t $c $(sname)}_list( e->$c.$(sname) );
  802. .else
  803.         rfre_${ctypename $t $c $(sname)}( e->$c.$(sname) );
  804. .endif
  805. .endforeach
  806.         break;
  807.  
  808. .endforeach
  809.     default:
  810.         FATALTAG( (int) e->tag );
  811.     }
  812.     fre_$t( e );
  813. }
  814.  
  815. .endif
  816. .endforeach
  817. .foreach t $(need_rfre_list)
  818. .set stic_$t "static "
  819. .endforeach
  820. .foreach t $(want_rfre_list)
  821. .set stic_$t
  822. .endforeach
  823. .foreach t $(need_rfre_list)
  824. /* Recursively free a list of elements 'e' of type $t. */
  825. $(stic_$t)void rfre_$t_list( e )
  826.  $t_list e;
  827. {
  828.     unsigned int ix;
  829.  
  830.     if( e == $t_listNIL ){
  831.     return;
  832.     }
  833.     for( ix=0; ix<e->sz; ix++ ) rfre_$t( e->arr[ix] );
  834.     fre_$t_list( e );
  835. }
  836.  
  837. .endforeach
  838. /**************************************************
  839.  *    print_<type> and print_<type>_list routines *
  840.  **************************************************/
  841.  
  842. $(teststdc)
  843. .foreach t $(need_print)
  844. .if ${index $t $(want_print)}
  845. .else
  846. static void print_$t( $t );
  847. .endif
  848. .endforeach
  849. .foreach t $(need_print_list)
  850. .if ${index $t $(want_print_list)}
  851. .else
  852. static void print_$t_list( $t_list );
  853. .endif
  854. .endforeach
  855. #endif
  856.  
  857. .. Forward declarations
  858. .foreach t $(need_print)
  859. .if ${index $t $(want_print)}
  860. .else
  861. static void print_$t();
  862. .endif
  863. .endforeach
  864. .foreach t $(need_print_list)
  865. .if ${index $t $(want_print_list)}
  866. .else
  867. static void print_$t_list();
  868. .endif
  869. .endforeach
  870.  
  871. .foreach t $(need_print)
  872. .set stic_$t "static "
  873. .endforeach
  874. .foreach t $(want_print)
  875. .set stic_$t
  876. .endforeach
  877. .foreach t $(need_print)
  878. /* Print an element 't' of type '$t'
  879.    using print optimizer.
  880.  */
  881. $(stic_$t)void print_$t( t )
  882.  $t t;
  883. {
  884. .if ${strlen ${telmlist $t}}
  885.     if( t == $tNIL ){
  886.     printword( "@" );
  887.     return;
  888.     }
  889.     opentuple();
  890. .foreach sname ${telmlist $t}
  891. .if ${eq list ${ttypeclass $t $(sname)}}
  892.     print_${ttypename $t $(sname)}_list( t->$(sname) );
  893. .else
  894.     print_${ttypename $t $(sname)}( t->$(sname) );
  895. .endif
  896. .endforeach
  897.     closetuple();
  898. .else
  899.     if( t == $tNIL ){
  900.     printword( "@" );
  901.     return;
  902.     }
  903.     opencons();
  904.     switch( t->tag ){
  905. .foreach c ${conslist $t}
  906.     case TAG$c:
  907.         printword( "$c" );
  908. .foreach sname ${celmlist $t $c}
  909. .if ${eq list ${ctypeclass $t $c $(sname)}}
  910.         print_${ctypename $t $c $(sname)}_list( t->$c.$(sname) );
  911. .else
  912.         print_${ctypename $t $c $(sname)}( t->$c.$(sname) );
  913. .endif
  914. .endforeach
  915.         break;
  916.  
  917. .endforeach
  918.     default:
  919.         FATALTAG( (int) t->tag );
  920.     }
  921.     closecons();
  922. .endif
  923. }
  924.  
  925. .endforeach
  926. .foreach t $(need_print_list)
  927. .set stic_$t "static "
  928. .endforeach
  929. .foreach t $(want_print_list)
  930. .set stic_$t
  931. .endforeach
  932. .foreach t $(need_print_list)
  933. /* Print a list of elements 'l' of type '$t'
  934.    using print optimizer.
  935.  */
  936. $(stic_$t)void print_$t_list( l )
  937.  $t_list l;
  938. {
  939.     unsigned int ix;
  940.  
  941.     if( l == $t_listNIL ){
  942.     printword( "@" );
  943.     return;
  944.     }
  945.     openlist();
  946.     for( ix=0; ix<l->sz; ix++ ) print_$t( l->arr[ix] );
  947.     closelist();
  948. }
  949.  
  950. .endforeach
  951. /***************************************************
  952.  *   fprint_<type> and fprint_<type>_list routines *
  953.  ***************************************************/
  954.  
  955. $(teststdc)
  956. .foreach t $(need_fprint)
  957. .if ${index $t $(want_print)}
  958. .else
  959. static void fprint_$t( FILE *, $t );
  960. .endif
  961. .endforeach
  962. .foreach t $(need_fprint_list)
  963. .if ${index $t $(want_fprint_list)}
  964. .else
  965. static void fprint_$t_list( FILE *, $t_list );
  966. .endif
  967. .endforeach
  968. #endif
  969.  
  970. .. Forward declarations
  971. .foreach t $(need_fprint)
  972. .if ${index $t $(want_fprint)}
  973. .else
  974. static void fprint_$t();
  975. .endif
  976. .endforeach
  977. .foreach t $(need_fprint_list)
  978. .if ${index $t $(want_fprint_list)}
  979. .else
  980. static void fprint_$t_list();
  981. .endif
  982. .endforeach
  983.  
  984. .foreach t $(need_fprint)
  985. .set stic_$t "static "
  986. .endforeach
  987. .foreach t $(want_fprint)
  988. .set stic_$t
  989. .endforeach
  990. .foreach t $(need_fprint)
  991. /* Print a $t 't' to file 'f'. */
  992. $(stic_$t)void fprint_$t( f, t )
  993.  FILE *f;
  994.  $t t;
  995. {
  996.     if( t == $tNIL ){
  997.     fputs( "@ ", f );
  998.     return;
  999.     }
  1000.     putc( '(', f );
  1001. .if ${strlen ${telmlist $t}}
  1002. .set first 1
  1003. .foreach sname ${telmlist $t}
  1004. .if $(first)
  1005. .set first 0
  1006. .else
  1007.     fputs( ",\n", f );
  1008. .endif
  1009. .if ${eq list ${ttypeclass $t $(sname)}}
  1010.     fprint_${ttypename $t $(sname)}_list( f, t->$(sname) );
  1011. .else
  1012.     fprint_${ttypename $t $(sname)}( f, t->$(sname) );
  1013. .endif
  1014. .endforeach
  1015. .else
  1016.     switch( t->tag ){
  1017. .foreach c ${conslist $t}
  1018.     case TAG$c:
  1019.         fputs( "$c", f );
  1020. .foreach sname ${celmlist $t $c}
  1021.         putc( ' ', f );
  1022. .if ${eq list ${ctypeclass $t $c $(sname)}}
  1023.         fprint_${ctypename $t $c $(sname)}_list( f, t->$c.$(sname) );
  1024. .else
  1025.         fprint_${ctypename $t $c $(sname)}( f, t->$c.$(sname) );
  1026. .endif
  1027. .endforeach
  1028.         break;
  1029.  
  1030. .endforeach
  1031.     default:
  1032.         FATALTAG( (int) t->tag );
  1033.     }
  1034. .endif
  1035.     fputs( ")\n", f );
  1036. }
  1037.  
  1038. .endforeach
  1039. .foreach t $(need_fprint_list)
  1040. .set stic_$t "static "
  1041. .endforeach
  1042. .foreach t $(want_fprint_list)
  1043. .set stic_$t
  1044. .endforeach
  1045. .foreach t $(need_fprint_list)
  1046. /* Print a $t list 'l' to file 'f'. */
  1047. $(stic_$t)void fprint_$t_list( f, l )
  1048.  FILE *f;
  1049.  $t_list l;
  1050. {
  1051.     register unsigned int ix;
  1052.  
  1053.     if( l == $t_listNIL ){
  1054.     fputs( "@ ", f );
  1055.     return;
  1056.     }
  1057.     putc( '[', f );
  1058.     for( ix=0; ix<l->sz; ix++ ){
  1059.     if( ix!=0 ){
  1060.         fputc( ',', f );
  1061.     }
  1062.     fprint_$t( f, l->arr[ix] );
  1063.     }
  1064.     fputs( "]\n", f );
  1065. }
  1066.  
  1067. .endforeach
  1068. /**************************************************
  1069.  *    Duplication routines                        *
  1070.  **************************************************/
  1071.  
  1072. $(teststdc)
  1073. .foreach t $(need_rdup)
  1074. .if ${index $t $(want_rdup)}
  1075. .else
  1076. static $t rdup_$t( $t );
  1077. .endif
  1078. .endforeach
  1079. .foreach t $(need_rdup_list)
  1080. .if ${index $t $(want_rdup_list)}
  1081. .else
  1082. static $t_list rdup_$t_list( $t_list );
  1083. .endif
  1084. .endforeach
  1085. #endif
  1086.  
  1087. .. Forward declarations
  1088. .foreach t $(need_rdup)
  1089. .if ${index $t $(want_rdup)}
  1090. .else
  1091. static $t rdup_$t();
  1092. .endif
  1093. .endforeach
  1094. .foreach t $(need_rdup_list)
  1095. .if ${index $t $(want_rdup_list)}
  1096. .else
  1097. static $t_list rdup_$t_list();
  1098. .endif
  1099. .endforeach
  1100.  
  1101. .foreach t $(need_rdup)
  1102. .set stic_$t "static "
  1103. .endforeach
  1104. .foreach t $(want_rdup)
  1105. .set stic_$t
  1106. .endforeach
  1107. .foreach t $(need_rdup)
  1108. /* Recursively duplicate a $t element 'e'. */
  1109. $(stic_$t)$t rdup_$t( e )
  1110.  $t e;
  1111. {
  1112. .if ${strlen ${telmlist $t}}
  1113. .foreach e ${telmlist $t}
  1114. .if ${eq list ${ttypeclass $t $e}}
  1115.     ${ttypename $t $e}_list i_$e;
  1116. .else
  1117.     ${ttypename $t $e} i_$e;
  1118. .endif
  1119. .endforeach
  1120.  
  1121.     if( e == $tNIL ){
  1122.     return $tNIL;
  1123.     }
  1124. .foreach e ${telmlist $t}
  1125. .if ${eq list ${ttypeclass $t $e}}
  1126.     i_$e = rdup_${ttypename $t $e}_list( e->$e );
  1127. .else
  1128.     i_$e = rdup_${ttypename $t $e}( e->$e );
  1129. .endif
  1130. .endforeach
  1131.     return new_$t( ${seplist ", " ${prefix "i_" ${telmlist $t}}} );
  1132. .else
  1133. .. rdup_<cons>
  1134.     if( e == $tNIL ){
  1135.     return $tNIL;
  1136.     }
  1137.     switch( e->tag ){
  1138. .foreach c ${conslist $t}
  1139.     case TAG$c:
  1140.     {
  1141. .foreach e ${celmlist $t $c}
  1142. .if ${eq list ${ctypeclass $t $c $e}}
  1143.         ${ctypename $t $c $e}_list i_$e;
  1144. .else
  1145.         ${ctypename $t $c $e} i_$e;
  1146. .endif
  1147. .endforeach
  1148.  
  1149. .foreach e ${celmlist $t $c}
  1150. .if ${eq list ${ctypeclass $t $c $e}}
  1151.         i_$e = rdup_${ctypename $t $c $e}_list( e->$c.$e );
  1152. .else
  1153.         i_$e = rdup_${ctypename $t $c $e}( e->$c.$e );
  1154. .endif
  1155. .endforeach
  1156.         return new_$c( ${seplist ", " ${prefix "i_" ${celmlist $t $c}}} );
  1157.     }
  1158.  
  1159. .endforeach
  1160.     default:
  1161.         FATALTAG( (int) e->tag );
  1162.     }
  1163.     return $tNIL;
  1164. .endif
  1165. }
  1166.  
  1167. .endforeach
  1168. .foreach t $(need_rdup_list)
  1169. .set stic_$t "static "
  1170. .endforeach
  1171. .foreach t $(want_rdup_list)
  1172. .set stic_$t
  1173. .endforeach
  1174. .foreach t $(need_rdup_list)
  1175. /* Recursively duplicate $t list 'e'. */
  1176. $(stic_$t)$t_list rdup_$t_list( e )
  1177.  $t_list e;
  1178. {
  1179.     unsigned int ix;
  1180.     $t_list new;
  1181.  
  1182.     if( e == $t_listNIL ){
  1183.     return $t_listNIL;
  1184.     }
  1185.     new = new_$t_list();
  1186.     room_$t_list( new, e->sz );
  1187.     for( ix=0; ix<e->sz; ix++ ){
  1188.     new = append_$t_list( new, rdup_$t( e->arr[ix] ) );
  1189.     }
  1190.     return new;
  1191. }
  1192.  
  1193. .endforeach
  1194. /**************************************************
  1195.  *    Comparison routines.                        *
  1196.  **************************************************/
  1197.  
  1198. $(teststdc)
  1199. .foreach t $(need_cmp)
  1200. .if ${index $t $(want_cmp)}
  1201. .else
  1202. static int cmp_$t( $t, $t );
  1203. .endif
  1204. .endforeach
  1205. .foreach t $(need_cmp_list)
  1206. .if ${index $t $(want_cmp_list)}
  1207. .else
  1208. static int cmp_$t_list( $t_list, $t_list );
  1209. .endif
  1210. .endforeach
  1211. #endif
  1212.  
  1213. .. Forward declarations
  1214. .foreach t $(need_cmp)
  1215. .if ${index $t $(want_cmp)}
  1216. .else
  1217. static int cmp_$t();
  1218. .endif
  1219. .endforeach
  1220. .foreach t $(need_cmp_list)
  1221. .if ${index $t $(want_cmp_list)}
  1222. .else
  1223. static int cmp_$t_list();
  1224. .endif
  1225. .endforeach
  1226.  
  1227. .foreach t $(need_cmp)
  1228. .if ${index $t $(want_cmp)}
  1229. .set stat
  1230. .else
  1231. .set stat "static "
  1232. .endif
  1233. .if ${len ${telmlist $t}}
  1234. .. cmp_<tuple>
  1235. /* Compare two $t tuples. */
  1236. $(stat)int cmp_$t( a, b )
  1237.  register $t a;
  1238.  register $t b;
  1239. {
  1240.     register int res;
  1241.  
  1242.     res = 0;
  1243. .. A small optimization, but also takes care of NIL.
  1244.     if( a == b ){
  1245.     return 0;
  1246.     }
  1247.     if( a == $tNIL ){
  1248.     return -1;
  1249.     }
  1250.     if( b == $tNIL ){
  1251.     return 1;
  1252.     }
  1253. .set first 1
  1254. .foreach ename ${telmlist $t}
  1255. .if ${eq list ${ttypeclass $t $(ename)}}
  1256. .set tn ${ttypename $t $(ename)}_list
  1257. .else
  1258. .set tn ${ttypename $t $(ename)}
  1259. .endif
  1260. .if $(first)
  1261. .set first 0
  1262. .else
  1263.     if( res != 0 ){
  1264.     return res;
  1265.     }
  1266. .endif
  1267.     res = cmp_$(tn)( a->$(ename), b->$(ename) );
  1268. .endforeach
  1269.     return res;
  1270. }
  1271.  
  1272. .else
  1273. .. cmp_<cons>
  1274. /* Compare two $t constructors. */
  1275. $(stat)int cmp_$t( a, b )
  1276.  $t a;
  1277.  $t b;
  1278. {
  1279.     register int res;
  1280.  
  1281. .. A small optimization, but also takes care of NIL.
  1282.     if( a == b ){
  1283.     return 0;
  1284.     }
  1285.     if( a == $tNIL ){
  1286.     return -1;
  1287.     }
  1288.     if( b == $tNIL ){
  1289.     return 1;
  1290.     }
  1291.     res = ( (int)a->tag - (int)b->tag);
  1292.     if( res != 0 ){
  1293.     return res;
  1294.     }
  1295.     switch( a->tag )
  1296.     {
  1297. .foreach c ${conslist $t}
  1298.     case TAG$c:
  1299. .set first 1
  1300. .foreach ename ${celmlist $t $c}
  1301. .if ${eq list ${ctypeclass $t $c $(ename)}}
  1302. .set tn ${ctypename $t $c $(ename)}_list
  1303. .else
  1304. .set tn ${ctypename $t $c $(ename)}
  1305. .endif
  1306. .if $(first)
  1307. .set first 0
  1308. .else
  1309.         if( res != 0 ) break;
  1310. .endif
  1311.         res = cmp_$(tn)( a->$c.$(ename), b->$c.$(ename) );
  1312. .endforeach
  1313.         break;
  1314.  
  1315. .endforeach
  1316.         default:
  1317.         FATALTAG( (int) a->tag );
  1318.     }
  1319.     return res;
  1320. }
  1321.  
  1322. .endif
  1323. .endforeach
  1324. .foreach t $(need_cmp_list)
  1325. .if ${index $t $(want_cmp_list)}
  1326. .set stat
  1327. .else
  1328. .set stat "static "
  1329. .endif
  1330. /* Compare two $t lists. */
  1331. $(stat)int cmp_$t_list( a, b )
  1332.  register $t_list a;
  1333.  register $t_list b;
  1334. {
  1335.     register int res;
  1336.     register unsigned int ix;
  1337.  
  1338. .. A small optimization, but also takes care of NIL.
  1339.     if( a == b ){
  1340.     return 0;
  1341.     }
  1342.     if( a == $t_listNIL ){
  1343.     return -1;
  1344.     }
  1345.     if( b == $t_listNIL ){
  1346.     return 1;
  1347.     }
  1348.     ix = 0;
  1349.     while( ix<a->sz || ix<b->sz ){
  1350.     if( ix>=a->sz ){
  1351.         return -1;
  1352.     }
  1353.     if( ix>=b->sz ){
  1354.         return 1;
  1355.     }
  1356.     res = cmp_$t( a->arr[ix], b->arr[ix] );
  1357.     if( res != 0 ){
  1358.         return res;
  1359.     }
  1360.     ix++;
  1361.     }
  1362.     return 0;
  1363. }
  1364.  
  1365. .endforeach
  1366. /**************************************************
  1367.  *    Scan routines.                              *
  1368.  **************************************************/
  1369.  
  1370. $(teststdc)
  1371. .foreach t $(need_fscan)
  1372. .if ${index $t $(want_fscan)}
  1373. .else
  1374. static int fscan_$t( FILE *, $t * );
  1375. .endif
  1376. .endforeach
  1377. .foreach t $(need_fscan_list)
  1378. .if ${index $t $(want_fscan_list)}
  1379. .else
  1380. static int fscan_$t_list( FILE *, $t_list * );
  1381. .endif
  1382. .endforeach
  1383. #endif
  1384.  
  1385. .. Forward declarations
  1386. .foreach t $(need_fscan)
  1387. .if ${index $t $(want_fscan)}
  1388. .else
  1389. static int fscan_$t();
  1390. .endif
  1391. .endforeach
  1392. .foreach t $(need_fscan_list)
  1393. .if ${index $t $(want_fscan_list)}
  1394. .else
  1395. static int fscan_$t_list();
  1396. .endif
  1397. .endforeach
  1398.  
  1399. .foreach t $(need_fscan)
  1400. .set stic_$t "static "
  1401. .endforeach
  1402. .foreach t $(want_fscan)
  1403. .set stic_$t
  1404. .endforeach
  1405. .foreach t $(need_fscan)
  1406. .if ${strlen ${telmlist $t}}
  1407. .. tuple type
  1408. /* Read a tuple of type $t
  1409.    from file 'f' and allocate space for it.
  1410.    Set the pointer 'p' to point to that structure.
  1411.  */
  1412. $(stic_$t)int fscan_$t( f, p )
  1413.  FILE *f;
  1414.  $t *p;
  1415. {
  1416.     register short int err;
  1417.     int c;
  1418. .foreach ename ${telmlist $t}
  1419. .if ${eq list ${ttypeclass $t $(ename)}}
  1420. .set tn ${ttypename $t $(ename)}_list
  1421. .else
  1422. .set tn    ${ttypename $t $(ename)}
  1423. .endif
  1424.     $(tn) l_$(ename);
  1425. .endforeach
  1426.  
  1427. .. Note that separate assignment is necessary, since there may
  1428. .. be weird <type>NIL definitions ..
  1429. .foreach ename ${telmlist $t}
  1430. .if ${eq list ${ttypeclass $t $(ename)}}
  1431. .set tn ${ttypename $t $(ename)}_list
  1432. .else
  1433. .set tn    ${ttypename $t $(ename)}
  1434. .endif
  1435.     l_$(ename) = $(tn)NIL;
  1436. .endforeach
  1437.     *p = $tNIL;
  1438.     if( fscanspace( f ) ){
  1439.     return 1;
  1440.     }
  1441.     c = getc( f );
  1442.     if( c == '@' ){
  1443.     return 0;
  1444.     }
  1445.     ungetc( c, f );
  1446.     err = tmfneedc( f, '(' );
  1447.     if( err ){
  1448.     return 1;
  1449.     }
  1450. .set first 1
  1451. .foreach ename ${telmlist $t}
  1452. .if ${eq list ${ttypeclass $t $(ename)}}
  1453. .set tn ${ttypename $t $(ename)}_list
  1454. .else
  1455. .set tn    ${ttypename $t $(ename)}
  1456. .endif
  1457. .if $(first)
  1458. .set first 0
  1459. .else
  1460.     if( !err ) err = tmfneedc( f, ',' );
  1461. .endif
  1462.     if( !err ) err = fscan_$(tn)( f, &l_$(ename) );
  1463. .endforeach
  1464.     *p = new_$t( ${seplist ", " ${prefix " l_" ${telmlist $t}}} );
  1465.     if( err ){
  1466.     return 1;
  1467.     }
  1468.     return tmfneedc( f, ')' );
  1469. }
  1470.  
  1471. .else
  1472. /* Read an instance of a datastructure of type $t.
  1473.    from file 'f' and allocate space for it. Set the pointer 'p' to
  1474.    point to that structure.
  1475.  */
  1476. $(stic_$t)int fscan_$t( f, p )
  1477.  FILE *f;
  1478.  $t *p;
  1479. {
  1480.     register int n;
  1481.     int c;
  1482.     char tm_word[WORDBUFSIZE];
  1483.     register short int err = 0;
  1484.  
  1485.     *p = $tNIL;
  1486.     n = fscanopenbrac( f );
  1487.     if( fscanspace( f ) ){
  1488.     return 1;
  1489.     }
  1490.     c = getc( f );
  1491.     if( c == '@' ){
  1492.     return fscanclosebrac( f, n );
  1493.     }
  1494.     ungetc( c, f );
  1495.     if( fscancons( f, tm_word ) ){
  1496.     return 1;
  1497.     }
  1498. .. First time in loop there should be no 'else' before the if,
  1499. .. in all other cases there should.
  1500. .set els
  1501. .foreach c ${conslist $t}
  1502.     $(els)if( strcmp( tm_word, "$c" ) == 0 ){
  1503. .foreach ename ${celmlist $t $c}
  1504. .if ${eq list ${ctypeclass $t $c $(ename)}}
  1505. .set tn ${ctypename $t $c $(ename)}_list
  1506. .else
  1507. .set tn    ${ctypename $t $c $(ename)}
  1508. .endif
  1509.     $(tn) l_$(ename);
  1510. .endforeach
  1511.  
  1512. .foreach ename ${celmlist $t $c}
  1513. .if ${eq list ${ctypeclass $t $c $(ename)}}
  1514. .set tn ${ctypename $t $c $(ename)}_list
  1515. .else
  1516. .set tn    ${ctypename $t $c $(ename)}
  1517. .endif
  1518.     l_$(ename) = $(tn)NIL;
  1519.     if( !err) err = fscan_$(tn)( f, &l_$(ename) );
  1520. .endforeach
  1521.     *p = new_$c( ${seplist ", " ${prefix " l_" ${celmlist $t $c}}} );
  1522.     }
  1523. .set els "else "
  1524. .endforeach
  1525.     else {
  1526.     (void) sprintf( tmerrmsg, tm_badcons, "$t", tm_word );
  1527.     return 1;
  1528.     }
  1529.     if( err ){
  1530.     return 1;
  1531.     }
  1532.     return fscanclosebrac( f, n );
  1533. }
  1534.  
  1535. .endif
  1536. .endforeach
  1537. .foreach t $(need_fscan_list)
  1538. .set stic_$t "static "
  1539. .endforeach
  1540. .foreach t $(want_fscan_list)
  1541. .set stic_$t
  1542. .endforeach
  1543. .foreach t $(need_fscan_list)
  1544. /* Read an instance of a list of datastructure of type $t
  1545.    from file 'f' and allocate space for it. Set the pointer 'p' to
  1546.    point to that structure.
  1547.  */
  1548. $(stic_$t)int fscan_$t_list( f, p )
  1549.  FILE *f;
  1550.  $t_list *p;
  1551. {
  1552.     register short int err = 0;
  1553.     register int c;
  1554.     int n;
  1555.     $t new;
  1556.  
  1557.     *p = $t_listNIL;
  1558.     n = fscanopenbrac( f );
  1559.     if( fscanspace( f ) ){
  1560.     return 1;
  1561.     }
  1562.     c = getc( f );
  1563.     if( c == '@' ){
  1564.     return fscanclosebrac( f, n );
  1565.     }
  1566.     ungetc( c, f );
  1567.     if( tmfneedc( f, '[' ) ){
  1568.     return 1;
  1569.     }
  1570.     *p = new_$t_list();
  1571.     if( fscanspace( f ) ){
  1572.     return 1;
  1573.     }
  1574.     c = getc( f );
  1575.     if( c == ']' ){
  1576.     return 0;
  1577.     }
  1578.     if( c == EOF ){
  1579.     (void) strcpy( tmerrmsg, tm_badeof );
  1580.     return 1;
  1581.     }
  1582.     ungetc( c, f );
  1583.     for(;;){
  1584.     if( !err ) err = fscan_$t( f, &new );
  1585.     *p = append_$t_list( *p, new );
  1586.     if( err || fscanspace( f ) ){
  1587.         return 1;
  1588.     }
  1589.     c = getc( f );
  1590.     if( c == EOF ){
  1591.         (void) strcpy( tmerrmsg, tm_badeof );
  1592.         return 1;
  1593.     }
  1594.     if( c != ',' ){
  1595.         ungetc( c, f );
  1596.         break;
  1597.     }
  1598.     }
  1599.     if( tmfneedc( f, ']' ) ){
  1600.     return 1;
  1601.     }
  1602.     return fscanclosebrac( f, n );
  1603. }
  1604.  
  1605. .endforeach
  1606. /**************************************************
  1607.  *    del_<type>_list routines                    *
  1608.  **************************************************/
  1609.  
  1610. $(teststdc)
  1611. .foreach t $(need_del_list)
  1612. .if ${index $t $(want_del_list)}
  1613. .else
  1614. static int del_$t_list( $t_list, unsigned int );
  1615. .endif
  1616. .endforeach
  1617. #endif
  1618.  
  1619. .foreach t $(need_del_list)
  1620. .set stic_$t "static "
  1621. .endforeach
  1622. .foreach t $(want_del_list)
  1623. .set stic_$t
  1624. .endforeach
  1625. .foreach t $(need_del_list)
  1626. /* Delete '$t' element at position 'pos' in list 'l'. */
  1627. $(stic_$t)void del_$t_list( l, pos )
  1628.  register $t_list l;
  1629.  unsigned int pos;
  1630. {
  1631.     register unsigned int ix;
  1632.  
  1633.     if( l == $t_listNIL ){
  1634.     FATAL( tm_nilptr );
  1635.     }
  1636.     if( pos >= l->sz ){
  1637.     return;
  1638.     }
  1639.     rfre_$t( l->arr[pos] );
  1640.     l->sz--;
  1641.     for( ix=pos; ix<l->sz; ix++ ){
  1642.     l->arr[ix] = l->arr[ix+1];
  1643.     }
  1644. }
  1645.  
  1646. .endforeach
  1647. /************************************************************
  1648. *    Miscellaneous routines                                 *
  1649. ************************************************************/
  1650. .if ${index flush_$(basename) $(need_misc)}
  1651. /* Flush the allocation caches. */
  1652. void flush_$(basename)()
  1653. {
  1654. #ifdef USECACHE
  1655.     register short int ix;
  1656.  
  1657. .foreach t ${uniq $(need_new_list) $(need_fre_list)}
  1658.     for( ix=0; ix<cacheix_$t_list; ix++ ){
  1659.     TMFREE( cache_$t_list[ix] );
  1660.     }
  1661.     cacheix_$t_list = 0;
  1662. .endforeach
  1663. .foreach t ${uniq $(need_new) $(need_fre)}
  1664.     for( ix=0; ix<cacheix_$t; ix++ ){
  1665.     TMFREE( cache_$t[ix] );
  1666.     }
  1667.     cacheix_$t = 0;
  1668. .endforeach
  1669. #endif
  1670. }
  1671.  
  1672. .endif
  1673. .if $(statcode)
  1674. /* Print allocation and freeing statistics to file 'f'. */
  1675. void stat_$(basename)( f )
  1676.  FILE *f;
  1677. {
  1678. #ifdef STAT
  1679. .foreach t $(need_stat_list)
  1680.     fprintf( f, tm_allocfreed, "[$t]", newcnt_$t_list, frecnt_$t_list, hitcnt_$t_list, ((newcnt_$t_list==frecnt_$t_list)? "": "<-") );
  1681. .endforeach
  1682. .foreach t $(need_stat)
  1683. .if ${strlen ${telmlist $t}}
  1684.     fprintf(f,tm_allocfreed,"$t",newcnt_$t,frecnt_$t,hitcnt_$t,((newcnt_$t==frecnt_$t)? "": "<-") );
  1685. .else
  1686. .foreach c ${conslist $t}
  1687.     fprintf(f,tm_allocfreed,"$c",newcnt_$c,frecnt_$c,hitcnt_$c,((newcnt_$c==frecnt_$c)? "": "<-") );
  1688. .endforeach
  1689. .endif
  1690. .endforeach
  1691. #else
  1692.     f = f; /* to prevent 'f unused' from compiler and lint */
  1693. #endif
  1694. }
  1695.  
  1696. .endif
  1697. #else
  1698. /* WARNING: The code below is dummy code to fool lint. */
  1699.  
  1700. /* new_<cons> and new_<type> routines */
  1701. .foreach t $(want_new)
  1702. .if ${len ${telmlist $t}}
  1703. $t new_$t( ${seplist ", " ${prefix p_ ${telmlist $t}}} )
  1704. .foreach sname ${telmlist $t}
  1705. .if ${eq list ${ttypeclass $t $(sname)}}
  1706.  ${ttypename $t $(sname)}_list p_$(sname);
  1707. .else
  1708.  ${ttypename $t $(sname)} p_$(sname);
  1709. .endif
  1710. .endforeach
  1711. {
  1712. .foreach e ${telmlist $t}
  1713.     p_$e = p_$e;
  1714. .endforeach
  1715.     return ($t)0;
  1716. }
  1717. .else
  1718. .foreach c ${conslist $t}
  1719. $t new_$c( ${seplist ", " ${prefix "p_" ${celmlist $t $c}}} )
  1720. .foreach sname ${celmlist $t $c}
  1721. .if ${eq list ${ctypeclass $t $c $(sname)}}
  1722.  ${ctypename $t $c $(sname)}_list p_$(sname);
  1723. .else
  1724.  ${ctypename $t $c $(sname)} p_$(sname);
  1725. .endif
  1726. .endforeach
  1727. {
  1728. .foreach e ${celmlist $t $c}
  1729.     p_$e = p_$e;
  1730. .endforeach
  1731.     return ($t)0;
  1732. }
  1733.  
  1734. .endforeach
  1735.  
  1736. .endif
  1737. .endforeach
  1738. .foreach t $(want_new_list)
  1739. $t_list new_$t_list(){ return ($t_list)0; }
  1740. .endforeach
  1741.  
  1742. /* room_<type>_list() routines */
  1743. .foreach t $(want_room_list)
  1744. void room_$t_list( l, n )
  1745.  $t_list l;
  1746.  unsigned int n;
  1747. {
  1748.     l = l;
  1749.     n = n;
  1750. }
  1751.  
  1752. .endforeach
  1753.  
  1754. /* app_<type>_list() routines */
  1755. .foreach t $(want_app_list)
  1756. void app_$t_list( l, e )
  1757.  $t_list l;
  1758.  $t e;
  1759. {
  1760.     l = l;
  1761.     e = e;
  1762. }
  1763. .endforeach
  1764.  
  1765. /* append_<type>_list() routines */
  1766. .foreach t $(want_append_list)
  1767. $t_list append_$t_list( l, e )
  1768.  $t_list l;
  1769.  $t e;
  1770. {
  1771.     e = e;
  1772.     return l;
  1773. }
  1774.  
  1775. .endforeach
  1776.  
  1777. /* ins_<type>_list() routines */
  1778. .foreach t $(want_ins_list)
  1779. void ins_$t_list( l, ix, e )
  1780.  $t_list l;
  1781.  unsigned int ix;
  1782.  $t e;
  1783. {
  1784.     l=l;
  1785.     ix=ix;
  1786.     e=e;
  1787. }
  1788.  
  1789. .endforeach
  1790.  
  1791. /* del_<type>_list() routines */
  1792. .foreach t $(want_del_list)
  1793. void del_$t_list( l, ix )
  1794.  $t_list l;
  1795.  unsigned int ix;
  1796. {
  1797.     l=l;
  1798.     ix=ix;
  1799. }
  1800.  
  1801. .endforeach
  1802.  
  1803. /* conc_<type>_list() routines */
  1804. .foreach t $(want_conc_list)
  1805. void conc_$t_list( a, b )
  1806.  $t_list a, b;
  1807. {
  1808.     a=a;
  1809.     b=b;
  1810. }
  1811.  
  1812. .endforeach
  1813.  
  1814. /* concat_<type>_list() routines */
  1815. .foreach t $(want_concat_list)
  1816. $t_list concat_$t_list( a, b ) $t_list a, b;
  1817. {
  1818.     b=b;
  1819.     return a;
  1820. }
  1821. .endforeach
  1822.  
  1823. /* fre_<type>_list() routines */
  1824. .foreach t $(want_fre_list)
  1825. void fre_$t_list( l ) $t_list l; { l=l; }
  1826. .endforeach
  1827. .foreach t $(want_fre)
  1828. void fre_$t( e ) $t e; { e=e; }
  1829. .endforeach
  1830.  
  1831. /* rfre_<type>_list() routines */
  1832. .foreach t $(want_rfre_list)
  1833. void rfre_$t_list( l ) $t_list l; { l=l; }
  1834. .endforeach
  1835. .foreach t $(want_rfre)
  1836. void rfre_$t( e ) $t e; { e=e; }
  1837. .endforeach
  1838.  
  1839. /* print_<type>() routines */
  1840. .foreach t $(want_print)
  1841. void print_$t( e ) $t e; { e=e; }
  1842. .endforeach
  1843. .foreach t $(want_print_list)
  1844. void print_$t_list( l ) $t_list l; { l=l; }
  1845. .endforeach
  1846.  
  1847. /* fprint_<type>() routines */
  1848. .foreach t $(want_fprint)
  1849. void fprint_$t( f, e ) FILE *f; $t e; { f=f; e=e; }
  1850. .endforeach
  1851. .foreach t $(want_fprint_list)
  1852. void fprint_$t_list( f, l ) FILE *f; $t_list l; { f=f; l=l; }
  1853. .endforeach
  1854.  
  1855. /* rdup_<type>() routines */
  1856. .foreach t $(want_rdup)
  1857. $t rdup_$t( e ) $t e; { return e; }
  1858. .endforeach
  1859. .foreach t $(want_rdup_list)
  1860. $t_list rdup_$t_list( l ) $t_list l; { return l; }
  1861. .endforeach
  1862.  
  1863. /* fscan_<type>() routines */
  1864. .foreach t $(want_fscan)
  1865. int fscan_$t( f, p ) FILE *f; $t *p; { p=p; return f==f; }
  1866. .endforeach
  1867. .foreach t $(want_fscan_list)
  1868. int fscan_$t_list( f, l ) FILE *f; $t_list *l; { l=l; return f==f; }
  1869. .endforeach
  1870.  
  1871. /* cmp_<type>() routines */
  1872. .foreach t $(want_cmp)
  1873. int cmp_$t( a, b ) $t a, b; { return a==b; }
  1874. .endforeach
  1875. .foreach t $(want_cmp_list)
  1876. int cmp_$t_list( a, b ) $t_list a,b; { return a==b; }
  1877. .endforeach
  1878.  
  1879. /* misc. functions */
  1880. .if ${index flush_$(basename) $(want_misc)}
  1881. void flush_$(basename)(){}
  1882. .endif
  1883. .if ${index stat_$(basename) $(want_misc)}
  1884. void stat_$(basename)( f ) FILE *f; { f=f; }
  1885. .endif
  1886. #endif
  1887. /* ---- end of ${tplfilename} ---- */
  1888.